home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 003 / extenddb.arc / EXTENDDB.PRG < prev   
Text File  |  1986-02-19  |  17KB  |  476 lines
  1. * Filename : EXTENDDB.PRG
  2. * Program..: Clipper Extended Library
  3. * Notes....: User defined functions for upgrading Clipper to
  4. *            the *latest* version of dBASE III ... and beyond
  5. *
  6. *  dBASE III functions:
  7. *     ABS()       ::= Absolute value of a character
  8. *     ISALPHA()   ::= True if a character is alpha
  9. *     ISLOWER()   ::= True if a character is lowercase
  10. *     ISUPPER()   ::= True if a character is uppercase
  11. *     LEFT()      ::= Leftmost portion of a string
  12. *     MAX()       ::= Maximum of two numbers
  13. *     MIN()       ::= Minimum of two numbers
  14. *     MOD()       ::= Modulus of a number
  15. *     RIGHT()     ::= Rightmost portion of a string
  16. *     STUFF()     ::= Replace portion of a string
  17. *
  18. *  dBASE III functions simulated with a constant:
  19. *     DBF()       ::= Name of the database file in use
  20. *     FKLABEL()   ::= Name of a function key
  21. *     FKMAX()     ::= Maximum number of function keys
  22. *     NDX()       ::= Name of an index file to use
  23. *     OS()        ::= Name of the operating system
  24. *     VERSION()   ::= Name of the version of dBASE III
  25. *
  26. *  Latest dBASE III functions present in Clipper:
  27. *     dBASE:       Clipper:
  28. *     -----------  -----------
  29. *   same name:
  30. *     FOUND()      FOUND()      ::= Successful search in database file
  31. *     INKEY()      INKEY()      ::= User keypress druing program execution
  32. *     LTRIM()      LTRIM()      ::= String without leading blanks
  33. *     REPLICATE()  REPLICATE()  ::= String of <n> characters
  34. *     TRANSFORM()  TRANSFORM()  ::= Expression in the form of a picture
  35. *                                   template
  36. *   different name:
  37. *     FIELD()      FIELDNAME()  ::= Name of database field
  38. *     IIF()        IF()         ::= One expression or another
  39. *     READKEY()    LASTKEY()    ::= Keypress used to exit
  40. *                                   full-screen edits
  41. *     RECCOUNT()   LASTREC()    ::= Number of records in a database file
  42. *     RTRIM()      TRIM()       ::= String without trailing blanks
  43. *
  44. *  Clipper functions not in dBASE III:
  45. *     DTOS()     ::= Character string of date in format YYYYMMDD
  46. *                    Useful for index keys that concatenate dates and
  47. *                     character types
  48. *     EMPTY()    ::= True if expression has null or blank value
  49. *                    True if C = null or all spaces
  50. *                            D = CTOD("  /  /  ")
  51. *                            L = .F.
  52. *                            N = zero
  53. *     UPDATED()  ::= True if the user changed the GET variable during READ
  54. *
  55. *  Functions not in dBASE III or Clipper:
  56. *  Miscellaneous:
  57. *  --------------
  58. *  ALLTRIM()   ::= String with leading/trailing blanks removed
  59. *  LENNUM()    ::= Length of numeric number
  60. *  SOUNDEX()   ::= Soundex code of a word
  61. *  STRZERO()   ::= STR() of number with leading zeros instead of blanks
  62. *
  63. *
  64. *  Time Data:
  65. *  ----------
  66. *  AMPM()      ::= 12-hour time string with "am" or "pm"
  67. *  DAYS()      ::= Numeric days from numeric seconds
  68. *  ELAPTIME()  ::= Time string showing elapsed time
  69. *  SECONDS()   ::= Numeric seconds from time string
  70. *  TSTRING()   ::= Time string from numeric seconds
  71. *
  72. *
  73. ************************
  74.  
  75.  
  76. ***********************
  77. *  dBASE III functions:
  78. ***********************
  79.  
  80. FUNCTION ABS
  81. * Syntax: ABS( <expN> )
  82. * Return: The absolute value of a number
  83. *
  84. PARAMETERS cl_n
  85. RETURN IF(cl_n>=0, cl_n, -cl_n)
  86.  
  87. FUNCTION ISALPHA
  88. * Syntax: ISALPHA( <expC> )
  89. * Return: Logical true if the first character in <expC> is alpha
  90. *
  91. PARAMETERS cl_string
  92. RETURN UPPER(SUBSTR(cl_string,1,1)) $ [ABCDEFGHIJKLMNOPQRSTUVWXYZ]
  93.  
  94. FUNCTION ISLOWER
  95. * Syntax: ISLOWER( <expC> )
  96. * Return: Logical true if the first character in <expC> is lowercase
  97. *
  98. PARAMETERS cl_string
  99. RETURN SUBSTR(cl_string,1,1) $ [abcdefghijklmnopqrstuvwxyz]
  100.  
  101. FUNCTION ISUPPER
  102. * Syntax: ISUPPER( <expC> )
  103. * Return: Logical true if the first character in <expC> is uppercase
  104. *
  105. PARAMETERS cl_string
  106. RETURN SUBSTR(cl_string,1,1) $ [ABCDEFGHIJKLMNOPQRSTUVWXYZ]
  107.  
  108. FUNCTION LEFT
  109. * Syntax: LEFT( <expC>, <expN> )
  110. * Return: The leftmost <expN> characters of <expC>
  111. *
  112. PARAMETERS cl_string, cl_len
  113. RETURN SUBSTR(cl_string, 1, cl_len)
  114.  
  115. FUNCTION MAX
  116. * Syntax: MAX( <expN1>, <expN2> )
  117. * Return: The greater of two numbers
  118. *
  119. PARAMETERS cl_n1, cl_n2
  120. RETURN IF(cl_n1 > cl_n2, cl_n1, cl_n2)
  121.  
  122. FUNCTION MIN
  123. * Syntax: MIN( <expN1> , <expN2> )
  124. * Return: The lesser of two numbers
  125. *
  126. PARAMETERS cl_n1, cl_n2
  127. RETURN IF(cl_n1 < cl_n2, cl_n1, cl_n2)
  128.  
  129. FUNCTION MOD
  130. * Syntax: MOD( <expN1>, <expN2> )
  131. * Return: The remainder of <expN1> divided by <expN2>
  132. * Note..: Difference between the dBASE modulus function and the
  133. *         Clipper modulus operator is indicated by an arrow <-->:
  134. *
  135. *         Clipper operator:        dBASE function:
  136. *         -----------------        ---------------
  137. *         3 %  3 ::=  0.00           MOD( 3, 3) ::=  0
  138. *         3 %  2 ::=  1.00           MOD( 3, 2) ::=  1
  139. *         3 %  1 ::=  0.00           MOD( 3, 1) ::=  0
  140. *         3 %  0 ::=  0.00   <-->    MOD( 3, 0) ::=  3
  141. *         3 % -1 ::=  0.00           MOD( 3,-1) ::=  0
  142. *         3 % -2 ::=  1.00   <-->    MOD( 3,-2) ::= -1
  143. *         3 % -3 ::=  0.00           MOD( 3,-3) ::=  0
  144. *
  145. *        -3 %  3 ::=  0.00           MOD(-3, 3) ::=  0
  146. *        -3 %  2 ::= -1.00   <-->    MOD(-3, 2) ::=  1
  147. *        -3 %  1 ::=  0.00           MOD(-3, 1) ::=  0
  148. *        -3 %  0 ::=  0.00   <-->    MOD(-3, 0) ::= -3
  149. *        -3 % -1 ::=  0.00           MOD(-3,-1) ::=  0
  150. *        -3 % -2 ::= -1.00           MOD(-3,-2) ::= -1
  151. *        -3 % -3 ::=  0.00           MOD(-3,-3) ::=  0
  152. *
  153. *         3 %  3 ::=  0.00           MOD( 3, 3) ::=  0
  154. *         2 %  3 ::=  2.00           MOD( 2, 3) ::=  2
  155. *         1 %  3 ::=  1.00           MOD( 1, 3) ::=  1
  156. *         0 %  3 ::=  0.00           MOD( 0, 3) ::=  0
  157. *        -1 %  3 ::= -1.00   <-->    MOD(-1, 3) ::=  2
  158. *        -2 %  3 ::= -2.00   <-->    MOD(-2, 3) ::=  1
  159. *        -3 %  3 ::=  0.00           MOD(-3, 3) ::=  0
  160. *
  161. *         3 % -3 ::=  0.00           MOD( 3,-3) ::=  0
  162. *         2 % -3 ::=  2.00   <-->    MOD( 2,-3) ::= -1
  163. *         1 % -3 ::=  1.00   <-->    MOD( 1,-3) ::= -2
  164. *         0 % -3 ::=  0.00           MOD( 0,-3) ::=  0
  165. *        -1 % -3 ::= -1.00           MOD(-1,-3) ::= -1
  166. *        -2 % -3 ::= -2.00           MOD(-2,-3) ::= -2
  167. *        -3 % -3 ::=  0.00           MOD(-3,-3) ::=  0
  168. *
  169. PARAMETERS cl_num, cl_base
  170. PRIVATE cl_result
  171. cl_result = cl_num % cl_base
  172. RETURN IF( cl_base = 0, cl_num,;
  173.            IF(cl_result*cl_base < 0, cl_result+cl_base, cl_result))
  174.  
  175. FUNCTION RIGHT
  176. * Syntax: RIGHT( <expC>, <expN> )
  177. * Return: The rightmost <expN> characters of <expC>
  178. *
  179. PARAMETERS cl_string, cl_len
  180. RETURN SUBSTR(cl_string, LEN(cl_string)-cl_len+1)
  181.  
  182. FUNCTION STUFF
  183. * Syntax: STUFF( <expC1>, <expN1>, <expN2>, <expC2> )
  184. * Return: <expC1> with the portion starting at <expN1> and
  185. *         going for a length of <expN2> being replaced by <expC2>
  186. *
  187. PARAMETERS cl_string, cl_start, cl_len, cl_replace
  188. RETURN SUBSTR(cl_string,1,cl_start-1) + cl_replace +;
  189.        SUBSTR(cl_string,cl_start+cl_len)
  190.  
  191. *************************************************
  192. *  dBASE III functions simulated with a constant
  193. *************************************************
  194.  
  195. FUNCTION DBF
  196. * Syntax: DBF()
  197. * Return: The string "DBF" if a database file is in use
  198. * Note..: Supposed to return the name of the currently selected
  199. *         database file.
  200. *
  201. RETURN IF([]<FIELDNAME(1), "DBF", [])
  202.  
  203. FUNCTION FKLABEL
  204. * Syntax: FKLABEL( <expN>)
  205. * Return: The name of the <expN>th programmable function key
  206. * Note..: F1 is reserved, so the first *programmable* function key is F2
  207. *
  208. PARAMETERS cl_1
  209. RETURN IF(cl_1<10, "F"+LTRIM(STR(cl_1+1)), [])
  210.  
  211. FUNCTION FKMAX
  212. * Syntax: FMAX()
  213. * Return: The maximum number of programmable function keys on the computer
  214. * Note..: F1 is reserved for help, so the first *programmable* function
  215. *         key is F2
  216. RETURN 9     && IBM specific
  217.  
  218. FUNCTION NDX
  219. * Syntax: NDX( <expN> )
  220. * Return: The string "NTX<expN>"
  221. * Note..: Return the name of the index file in the <expN> position
  222. *         of the index file list of the command that opened the index file
  223. *
  224. PARAMETERS cl_1
  225. RETURN "NTX" + LTRIM(STR(cl_1)
  226.  
  227. FUNCTION OS
  228. * Syntax: OS()
  229. * Return: The name of the operating system
  230. *
  231. RETURN "MS/PC-DOS"   && DOS specific, MicroSoft or IBM
  232.  
  233. FUNCTION VERSION
  234. * Syntax: VERSION()
  235. * Return: The name of current dBASE III or Clipper version
  236. * Note..: Remember to change this when you update your Clipper version
  237. *
  238. RETURN "Clipper, Fall '85"
  239.  
  240. ********************************************************
  241. *  dBASE III functions with a different name in Clipper:
  242. ********************************************************
  243.  
  244. * FUNCTION FIELD is not needed because FIELD
  245. * is a valid abbreviation of FIELDNAME.
  246.  
  247. FUNCTION IIF
  248. * Syntax: IIF( <expL>, <exp1>, <exp2> )
  249. * Return: <exp1> if <expL> is true, or <exp2> if <expL> is false
  250. * Note..: <exp1> and <exp2> must be the same type
  251. *
  252. PARAMETERS cl_if1, cl_if2, cl_if3
  253. RETURN IF(cl_if1, cl_if2, cl_if3)
  254.  
  255. FUNCTION READKEY
  256. * Syntax: READKEY()
  257. * Return: A number representing the key pressed to exit from fullscreen mode
  258. * Note..: Differences between dBASE's READKEY() and Clipper's LASTKEY():
  259. *
  260. *         Exit Key:      dBASE:      Clipper:
  261. *         ---------      ------      --------
  262. *         Backspace         0        no exit
  263. *         ^D, ^L            1        no exit
  264. *         Lt arrow          2        no exit
  265. *         Rt arrow          3        no exit
  266. *         Up arrow          4        no exit
  267. *         Dn arrow          5        no exit
  268. *         PgUp              6          18
  269. *         PgDn              7           3
  270. *         Esc, ^Q          12          27 (Esc only)
  271. *         ^End, ^W         14          23 (^W only)
  272. *         type past end    15        ascii of last char typed
  273. *         Enter            15          13
  274. *         ^Home            33        no exit
  275. *         ^PgUp            34          31
  276. *         ^PgDn            35          30
  277. *         F1               36        no exit
  278. *
  279. *     dBASE III adds 256 to the exit code if the user changed anything
  280. *     Clipper uses its UPDATED() function to determine if anything changed
  281. *
  282. DO CASE
  283.    CASE LASTKEY() = 18                          && PgUp
  284.       RETURN 6 + IF(UPDATED(),256,0)
  285.    CASE LASTKEY() = 3                           && PgDn
  286.       RETURN 7 + IF(UPDATED(),256,0)
  287.    CASE LASTKEY() = 27                          && Esc
  288.       RETURN 12 + IF(UPDATED(),256,0)
  289.    CASE LASTKEY() = 23                          && ^W
  290.       RETURN 14 + IF(UPDATED(),256,0)
  291.    CASE LASTKEY() = 13                          && Enter
  292.       RETURN 15 + IF(UPDATED(),256,0)
  293.    CASE LASTKEY() = 31                          && ^PgUp
  294.       RETURN 34 + IF(UPDATED(),256,0)
  295.    CASE LASTKEY() = 30                          && ^PgDn
  296.       RETURN 35 + IF(UPDATED(),256,0)
  297.    CASE LASTKEY() >= 32                         && type past end
  298.       RETURN 15 + IF(UPDATED(),256,0)
  299. ENDCASE
  300.  
  301. FUNCTION RECCOUNT()
  302. * Syntax: RECCOUNT()
  303. * Return: The number of records in the currently selected database file
  304. *
  305. RETURN LASTREC()
  306.  
  307. FUNCTION RTRIM
  308. * Syntax: RTRIM( <expC> )
  309. * Return: <expC> without trailing blanks
  310. *
  311. PARAMETERS cl_string
  312. RETURN TRIM(cl_string)
  313.  
  314.  
  315. *************************************
  316. *  Functions not in dBASE or Clipper:
  317. *************************************
  318.  
  319. FUNCTION ALLTRIM
  320. * Syntax: ALLTRIM( <expC> )
  321. * Return: The <expC> without leading or trailing blanks
  322. *
  323. PARAMETERS cl_string
  324. RETURN LTRIM(TRIM(cl_string))
  325.  
  326. FUNCTION LENNUM
  327. * Syntax: LENNUM( <expN> )
  328. * Return: The length of <expN>
  329. *
  330. PARAMETERS cl_number
  331. RETURN LEN(LTRIM(STR(cl_number)))
  332.  
  333. FUNCTION SOUNDEX
  334. * Syntax: SOUNDEX( <expC> )
  335. * Return: A code in the form A9999 from a name
  336. * Note..: This algorithm is by Donald E. Knuth from
  337. *         The Art of Computer Programming, Vol. 3,
  338. *         "Sorting and Searching", page 392.
  339. *
  340. PARAMETERS cl_name
  341. PRIBATE cl_name, cl_code, cl_pointer
  342. cl_name = UPPER(cl_name)
  343. cl_code = SUBSTR(cl_name,1,1)
  344. cl_pointer = 2
  345. DO WHILE cl_pointer <= LEN(cl_name) .AND. LEN(cl_code) < 5
  346.    DO CASE
  347.       CASE SUBSTR(cl_name,cl_pointer,1) $ "BFPV"
  348.          cl_code = cl_code +;
  349.                    IF(SUBSTR(cl_code,LEN(cl_code),1)#"1","1",[])
  350.       CASE SUBSTR(cl_name,cl_pointer,1) $ "CGJKQSXZ"
  351.          cl_code = cl_code +;
  352.                    IF(SUBSTR(cl_code,LEN(cl_code),1)#"2","2",[])
  353.       CASE SUBSTR(cl_name,cl_pointer,1) $ "DT"
  354.          cl_code = cl_code +;
  355.                    IF(SUBSTR(cl_code,LEN(cl_code),1)#"3","3",[])
  356.       CASE SUBSTR(cl_name,cl_pointer,1) $ "L"
  357.          cl_code = cl_code +;
  358.                    IF(SUBSTR(cl_code,LEN(cl_code),1)#"4","4",[])
  359.       CASE SUBSTR(cl_name,cl_pointer,1) $ "MN"
  360.          cl_code = cl_code +;
  361.                    IF(SUBSTR(cl_code,LEN(cl_code),1)#"5","5",[])
  362.       CASE SUBSTR(cl_name,cl_pointer,1) $ "R"
  363.          cl_code = cl_code +;
  364.                    IF(SUBSTR(cl_code,LEN(cl_code),1)#"6","6",[])
  365.    ENDCASE
  366.    cl_pointer = cl_pointer + 1
  367. ENDDO
  368. RETURN cl_code + TRIM(SUBSTR( "0000 ", LEN(cl_code)))
  369.  
  370. FUNCTION STRZERO
  371. * Syntax: STRZERO( <expN>, [<length> [,<decimals>]] )
  372. * Return: The STR() of <expN> with leading zeros instead of blanks
  373. *
  374. PARAMETERS cl_num, cl_len, cl_dec
  375. PRIVATE cl_str
  376. DO CASE
  377.    CASE TYPE('cl_dec') # "U"
  378.       cl_str = STR(cl_num,cl_len,cl_dec)
  379.    CASE TYPE('cl_len') # "U"
  380.       cl_str + STR(cl_num,cl_len)
  381.    OTHERWISE
  382.       cl_str = STR(cl_num)
  383. ENDCASE
  384. IF "-" $ cl_str   && negative number
  385.    * move the minus sign to appear in front of the zeros
  386.    RETURN "-" + REPLICATE( "0", LEN(cl_str)-LEN(LTRIM(cl_str))) +;
  387.                 SUBSTR(cl_str, AT("-",cl_str)+1)
  388. ELSE   && positive number
  389.    RETURN REPLICATE( "0", LEN(cl_str)-LEN(LTRIM(cl_str))) +;
  390.           LTRIM(cl_str)
  391. ENDIF
  392.  
  393. ************
  394. * Time Data:
  395. ************
  396.  
  397. * A valid time string comprises eight characters in the
  398. *   form HH:MM:SS with the range 00:00:00 to 23:59:59
  399. *
  400. * Expression to validate a time string entry
  401. * timestring = [  :  :  ]
  402. * @...GET timestring PICTURE [99:99:99] ;
  403. *                    VALID VAL(       timestring   ) < 24 .AND. ;
  404. *                          VAL(SUBSTR(timestring,4)) < 60 .ANd. ;
  405. *                          VAL(SUBSTR(timestring,7)) < 60
  406.  
  407. FUNCTION AMPM
  408. * Syntax: AMPM( <time string> )
  409. * Return: An 11 byte character string with the time in a 12-hour am/pm fmt.
  410. *
  411. PARAMETERS cl_time
  412. RETURN IF(        VAL(cl_time)<12, cl_time + " am",;
  413.            IF(    VAL(cl_time)=12, cl_time + " pm",;
  414.               STR(VAL(cl_time)-12,2) + SUBSTR(cl_time,3) + " pm"))
  415.  
  416. FUNCTION DAYS
  417. * Syntax: DAYS( <seconds> )
  418. * Return: Integer number of days from numeric seconds
  419. * Note..: The remainder under 24 hours is returned by the TSTRING() function
  420. *
  421. PARAMETERS cl_secs
  422. RETURN INT(cl_secs / 86400)
  423.  
  424. FUNCTION ELAPTIME
  425. * Syntax: ELAPTIME( <start time>, <end time> )
  426. * Return: A time string showing the difference between start and end time
  427. * Note..: If start time is greater than end time, this algorithm assumes
  428. *         that the day changed at midnight.
  429. *         Only good for timings under 24 hours. 86400 is the number of
  430. *         seconds in 24 hours.
  431. *
  432. PARAMETERS cl_start, cl_end
  433. RETURN TSTRING( IF(cl_end<cl_start,86400,0)+;
  434.                 SECONDS(cl_end) - SECONDS(cl_start))
  435.  
  436. FUNCTION SECONDS
  437. * Syntax: SECONDS( <time string> )
  438. * Return: Numeric seconds as a quantity of the time string
  439. * Note..: Seconds in time period
  440. *         -------    -----------
  441. *              60    1 minute
  442. *            3600    1 hour
  443. *           84600    1 day
  444. *
  445. PARAMETERS cl_time
  446. RETURN VAL(       cl_time   ) * 3600 +;
  447.        VAL(SUBSTR(cl_time,4)) *   60 +;
  448.        VAL(SUBSTR(cl_time,7))
  449.  
  450. FUNCTION TSTRING
  451. * Syntax: TSTRING( <seconds>
  452. * Return: A 24-hour time string from numeric seconds
  453. * Note..: Time quantities over 24 hours are returned by the DAYS() function
  454. *
  455. PARAMETERS cl_secs
  456. RETURN STRZERO( INT(MOD(cl_secs/3600, 24)),2, 0) + ':'+;
  457.        STRZERO( INT(MOD(cl_secs/  60, 60)),2, 0) + ':'+;
  458.        STRZERO( INT(MOD(cl_secs     , 60)),2, 0)
  459.  
  460. *************************
  461. * External Declarations:
  462. *************************
  463.  
  464. * User=defined fucntions written in other languages where the object
  465. * file is included at link time must be declared external in order for
  466. * them to be used in a "non-explicit" syntax such as in an index
  467. * <expression> or within a report or label form
  468. *
  469. EXTERNAL ISCOLOR, ISPRINTER                             && in Extends.asm
  470. EXTERNAL DISKSPACE, GETE, HEADER, LUPDATE, RECSIZE      && in Extendc.c
  471.  
  472. * EOF: Extenddb.prg ************************
  473.  
  474.  
  475.  
  476.